home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
subjct30.zip
/
SUBJECT.BAS
next >
Wrap
BASIC Source File
|
1990-10-10
|
25KB
|
851 lines
' --------------------------------------------------------
'
' Dedicated to the devotional service of Lord Shri Krishna
'
' by Vaishnava dasa on 10/20/89
' Release 3.0 on 10/10/90
'
'
' Version 1.0 (10/20/89)
' Version 1.1 (10/21/89)
' Version 1.2 (10/21/89)
' Version 1.3 (11/28/89)
' Version 1.4 (12/13/89)
' Version 1.4 (12/18/89)
' o Reads format file (default "SUBJECT.TMP" on default drive) for
' customizing output file using "F:" optional command-line
' parameter. Recognizes these format strings:
' 1) TODATExx - date of latest message
' 2) FMDATExx - date of earliest message
' 3) MSG - number of messages in conference
' 4) AREA - name of conference given in command line. SUBJECT.exe
' will overwrite 16 characters following "AREA" string
' when copying from the format file to the output file.
' This is needed if you make a generic template format
' file where AREA variables vary in length. If you are
' using one template per conference, you can omit this
' AREA variable and just put the name of the conference
' in the template file
' 5) SUBJECT8901234567890 - 20 characters for SUBJECT string
' 6) ### - 3 characters for number of messages in SUBJECT thread
'
' When using new "F:" parameter, all the above format string
' variables are optional. Command line parameters "S:", "D:" and
' "L:" are ignored. Using the "F:" parameter assumes that you
' will put in your own Smart-text commands. Will even work with
' format files using ansi commands (as done by THEDRAW) as long as
' the above strings can be found in the format file
'
' Version 2.0 (12/25/89)
' Version 2.1 (5/31/90)
' o Gets rid of G:, A:, B:, and F:C parameters.
' o Compatible with RBBS-PC Version 17.3
' o Strips "RE:" from Subjects
'
' Version 3.0 (10/10/90)
' o Got rid of all internal format for Smart-text; this means
' that (*.tmp) template files are absolutely required
' o No more command-line parameters supported except ones
' absolutely required (i.e. I:, O:, and C:)
' o SUBJECT will only support making all three *W.DEF files,
' namely, *W.DEF, *WG.DEF, and *WC.DEF. I have no idea if
' this will be backwardly compatible with RBBS-PC prior to
' Version 17.3
' o Now SUBJECT will support full 25 character SUBJECTs in output
' This is not backwardly compatible with any previous release of
' SUBJECT.EXE, or the previous default-sample *.TMP files
' New sample *.TMP files will be included with this release
'
' --------------------------------------------------------
'
' SUBJECT Version 3.x - A RBBS-PC Conference messages utility
'
' Use: Scans RBBS-PC messages files and writes a file listing
' ~~~ the most popular threads in descending order. Formatting
' options dependent solely on required *.TMP template files.
'
DEFINT A-Z
DECLARE SUB comline (n, a$(), max)
DECLARE SUB center (a$, pad, ret)
DECLARE SUB delayit (secs, display)
pad = 1
ret = 1
false = 0
true = NOT false
restrow = 1
restcol = 1
ON ERROR GOTO HANDLER
' DECLARE AN ARRAY TO GET COMMANDLINE PARAMETERS
DIM a$(1 TO 4)
CALL comline(n, a$(), 4)
IF n = 0 THEN GOTO showcommands
FOR showarray = 1 TO 4
IF INSTR(a$(showarray), "I:") <> 0 THEN
filename$ = MID$(a$(showarray), 3, 255)
END IF
IF INSTR(a$(showarray), "O:") <> 0 THEN
outputfile$ = MID$(a$(showarray), 3, 255)
END IF
IF INSTR(a$(showarray), "C:") <> 0 THEN
confname$ = MID$(a$(showarray), 3, 12)
END IF
IF INSTR(a$(showarray), "?") <> 0 THEN
helptext = true
END IF
NEXT showarray
ERASE a$
' IF REQUIRED PARAMETERS MISSING, GOTO SHOW HIM WHAT'S WRONG HERE
IF LEN(filename$) = 0 THEN GOTO showcommands
IF LEN(outputfile$) = 0 THEN GOTO showcommands
IF LEN(confname$) = 0 THEN GOTO showcommands
IF helptext THEN GOTO showcommands
' DEFINE RBBS-PC's MESSAGE HEADER RECORD
TYPE recordtype
private AS STRING * 1
numb1mess AS STRING * 4
namemsgfrom AS STRING * 31
namemsgto AS STRING * 22
notused1 AS STRING * 9
mmdate AS STRING * 2
notused1a AS STRING * 1
dddate AS STRING * 2
notused1b AS STRING * 1
yydate AS STRING * 2
subject AS STRING * 25
notused2 AS STRING * 15
alive AS STRING * 1
recnos AS STRING * 4
notused3 AS STRING * 8
END TYPE
' DEFINE RBBS-PC's CHECKPOINT RECORD
TYPE checkrecord
maximess AS STRING * 8
not2used AS STRING * 59
locatefirstmess AS STRING * 7
noteverused1 AS STRING * 54
END TYPE
' DEFINE SUBJECT ARRAY
TYPE tosort
titles AS STRING * 25
END TYPE
' DEFINE SUBJECT ARRAY WITH NUMBER OF COUNT
TYPE tosort2
titles2 AS STRING * 25
amount AS STRING * 3
END TYPE
DIM arecord AS recordtype
DIM firstrecord AS checkrecord
' FORMAT OUTPUT HEADER DISPLAY
CLS
a1$ = "SUBJECT Version 3.0 - A RBBS-PC Automatic Conference Welcome-file Maker"
a2$ = STRING$(LEN(a1$), CHR$(205))
a3$ = "Written by Vaishnava dasa - Krishna Yoga Foundation BBS"
a4$ = "FidoNet 1:115/800 - 312/743-6116"
a5$ = CHR$(34) + "Chant " + CHR$(96) + "Hare Krishna" + CHR$(39) + " and be happy" + CHR$(34)
a6$ = "Use SUBJECT 3.0 with RBBS-PC Version 17.3"
a7$ = "SUBJECT is also ideal with MSGTOSS: The Fast RBBS-PC Mail-tosser!"
a$ = a1$
CALL center(a$, pad, ret)
a$ = a2$
CALL center(a$, pad, ret)
a$ = a3$
CALL center(a$, pad, ret)
a$ = a4$
CALL center(a$, pad, ret)
a$ = a5$
CALL center(a$, pad, ret)
PRINT
a$ = a6$
CALL center(a$, pad, ret)
a$ = a7$
CALL center(a$, pad, ret)
restrow = CSRLIN
restcol = POS(0)
' SET UP ARRAY FOR SCREEN SAVING
DIM SCR(2000)
DSEG = VARSEG(SCR(1))
DOFS = VARPTR(SCR(1))
page = 0
scrmode = -1
CALL DSCRSAVE(DSEG, DOFS, page, scrmode)
CLS
' OPEN THE INPUT FILE AND READ SUBJECTS
OPEN filename$ FOR RANDOM SHARED AS #1
GET #1, 1, firstrecord
xx1$ = firstrecord.maximess
' NUMBER OF LAST MESSAGE IN MESSAGE BASE
max.mess = VAL(xx1$)
' RECORD NUMBER OF FIRST MESSAGE IN MESSAGE BASE
xx2$ = firstrecord.locatefirstmess
first.recno = VAL(xx2$)
' READ FIRST MESSAGE HEADER RECORD GET NUMBER OF THIS MESSAGE
GET #1, first.recno, arecord
xx3$ = arecord.numb1mess
first.messno = VAL(xx3$)
' GET TOTAL NUMBER OF MESSAGES IN MESSAGE BASE POSSIBLE
maxi = max.mess - first.messno + 1
' DEFINE 2 ARRAYS SUITABLE TO FIT
DIM myarray(1 TO (maxi + 1)) AS tosort
DIM mysorted(1 TO (maxi + 1)) AS tosort2
' ASSIGN NUMBER OF FIRST MESSAGE HEADER RECORD NUMBER TO "Q"
q = first.recno
' Y -> THE NUMBER OF ACTUAL SUBJECTS IN THIS MESSAGE BASE
y = 0
olddate$ = "991231"
recentdate$ = "800101"
' GET THE FIRST MESSAGE HEADER RECORD
GET #1, q, arecord
' NEW DISPLAY PORT FOR WATCHING MESSAGES
COLOR 14, 1
LOCATE 1, 1
PRINT STRING$(2000, CHR$(240));
LOCATE 1, 1
ulr = 5: ulc = 24
lrr = 19: lrc = 56
CALL mwindow(ulr, ulc, lrr, lrc)
LOCATE ulr, ulc
fore = 15: back = 19
frame = 1: label$ = "Subject:"
shadow = 0
grow = 1
CALL WindowManager(ulr, ulc, lrr, lrc, frame, fore, back, grow, shadow, label, label$, page, scrmode)
' GOTO BOTTOM OF WINDOW
LOCATE lrr, ulc + 1
' LOOP AGAIN UNTIL EXIT; Y MUST BE LESS THAN CALCULATED MAXIMUM
COLOR 15, 11
DO WHILE y <= maxi
' IF MESSAGE IS PRIVATE, "(R)", OR BLANK, THEN DISREGARD
IF arecord.private = "*" OR RTRIM$(arecord.subject) = "(R)" OR LEN(RTRIM$(LTRIM$(arecord.subject))) = 0 OR arecord.alive = CHR$(226) THEN
' UPDATE TO GET NEXT RECORD HEADER
q = q + VAL(arecord.recnos)
' CHECK NEXT RECORD FOR BAD RECORD NUMBER INFO, IF SO, ABORT
IF LEN(RTRIM$(LTRIM$(arecord.subject))) = 0 THEN
' ENCOUNTERED BLANK SUBJECT FIELD
GET #1, q, arecord
IF VAL(arecord.recnos) <= 0 OR VAL(arecord.recnos) > 9999 THEN
y = y - 1
EXIT DO
END IF
END IF
IF VAL(arecord.numb1mess) = VAL(xx1$) THEN
y = y - 1
EXIT DO
END IF
' MESSAGE IS OK, THEREFORE CONTINUE TO PROCESS
ELSE
' CHECK FOR NULLS IN SUBJECT AND REPLACE WITH SPACES
IF INSTR(arecord.subject, CHR$(0)) <> 0 THEN
DO WHILE INSTR(arecord.subject, CHR$(0)) <> 0
x = INSTR(arecord.subject, CHR$(0))
arecord.subject = MID$(arecord.subject, 1, x - 1) + " " + MID$(arecord.subject, x + 1, 25)
LOOP
END IF
' CHECK FOR (R)s AND REMOVE IF FOUND
DO
IF LEFT$(arecord.subject, 3) = "(R)" THEN
arecord.subject = MID$(arecord.subject, 4, 25)
END IF
LOOP WHILE LEFT$(arecord.subject, 3) = "(R)"
' CHECK FOR "RE:"s AND REMOVE IF FOUND
DO
IF LEFT$(arecord.subject, 3) = "RE:" THEN
arecord.subject = MID$(arecord.subject, 4, 25)
END IF
LOOP WHILE LEFT$(arecord.subject, 3) = "RE:"
' BEGIN ARRAY NUMBERS WITH "1"
IF y = 0 THEN y = 1
' STORE NUMBER "y" AND SUBJECT TO ARRAY
myarray(y).titles = arecord.subject
' GET NEXT MESSAGE HEADER RECORD NUMBER
q = q + VAL(arecord.recnos)
' GET MESSAGE DATE OF THIS MESSAGE IN YYMMDD FORMAT
messdate$ = arecord.yydate + arecord.mmdate + arecord.dddate
' CHECK TO SEE VALIDITY OF THIS DATE (NO ZEROS)
IF VAL(arecord.yydate) <> 0 AND VAL(arecord.mmdate) <> 0 AND VAL(arecord.dddate) <> 0 THEN
' COMPARE AGAINST OLDEST MESSAGE DATE AND REPLACE VALUE IF OLDER
IF LEFT$(messdate$, 1) <> " " AND messdate$ < olddate$ THEN
olddate$ = messdate$
END IF
' COMPARE AGAINST MOST RECENT DATE MESSAGE AND UPDATE IF NEED BE
IF messdate$ > recentdate$ THEN recentdate$ = messdate$
END IF
' FOR DISPLAY, SHOW SUBJECTS
PRINT RIGHT$(" " + STR$(y), 3) + " - " + LEFT$(arecord.subject, 1) + MID$(LCASE$(arecord.subject), 2)
CALL scroll(ulr, ulc, lrr, lrc, 1)
LOCATE lrr, ulc + 1
' IF FIRST MESSAGE IS LAST MESSAGE THEN EXIT DO
IF VAL(arecord.numb1mess) = VAL(xx1$) THEN EXIT DO
' INCREMENT Y VARIABLE FOR COUNTING
y = y + 1
' IF Y IS LARGER THAN ARRAY SIZE THEN LOWER BY 1 AND GET OUT
IF y > maxi THEN
y = y - 1
EXIT DO
END IF
END IF
GET #1, q, arecord
LOOP
IF y < 0 THEN y = 0
' FORMAT DATES WITH DASHES
olddate$ = MID$(olddate$, 3, 2) + "-" + RIGHT$(olddate$, 2) + "-" + LEFT$(olddate$, 2)
recentdate$ = MID$(recentdate$, 3, 2) + "-" + RIGHT$(recentdate$, 2) + "-" + LEFT$(recentdate$, 2)
' CLOSE THIS FILE AND SORT THE ARRAY
CLOSE #1
' FOR DISPLAY, SHOW END OF SCAN
FOR x = 1 TO 14
PRINT
CALL scroll(ulr, ulc, lrr, lrc, 1)
LOCATE lrr, ulc + 1
NEXT x
PRINT RIGHT$(" " + STR$(y), 3) + " - Messages total"
CALL scroll(ulr, ulc, lrr, lrc, 1)
FOR x = 1 TO 13
PRINT
CALL scroll(ulr, ulc, lrr, lrc, 1)
LOCATE lrr, ulc + 1
NEXT x
'RESTORE TO DIFFERENT COLOR
COLOR 15, 4
LOCATE 2, 1
a$ = SPACE$(LEN(a$))
CALL center(a$, pad, ret)
a$ = "Sorting..."
LOCATE 2, 1
CALL center(a$, pad, ret)
offset = y \ 2
DO WHILE offset > 0
Limit = y - offset
DO
switch = false
FOR counting = 1 TO Limit
IF myarray(counting).titles > myarray(counting + offset).titles THEN
SWAP myarray(counting), myarray(counting + offset)
switch = counting
END IF
NEXT counting
Limit = switch - offset
LOOP WHILE switch
offset = offset \ 2
LOOP
' TAKE THE ARRAY AND FILL SECOND ARRAY (MYSORTED) WITH SUBJECT AND AMOUNTS
f = 1
FOR doit = 1 TO y
x = 1
mysorted(f).titles2 = myarray(doit).titles
FOR newdoit = (doit + 1) TO y + 1
IF myarray(newdoit).titles = myarray(doit).titles THEN
x = x + 1
ELSE
mysorted(f).amount = RIGHT$((" " + LTRIM$(STR$(x))), 3)
doit = newdoit - 1
newdoit = y + 1
END IF
NEXT newdoit
f = f + 1
NEXT doit
ERASE myarray
' SORTING MYSORTED ARRAY BY TOTALS
f = f - 1
LOCATE 2, 1
a$ = SPACE$(LEN(a$))
CALL center(a$, pad, ret)
a$ = "Totaling..."
LOCATE 2, 1
CALL center(a$, pad, ret)
offset = f \ 2
DO WHILE offset > 0
Limit = f - offset
DO
switch = false
FOR counting = 1 TO Limit
IF mysorted(counting).amount < mysorted(counting + offset).amount THEN
SWAP mysorted(counting), mysorted(counting + offset)
switch = counting
ELSE
IF mysorted(counting).amount = mysorted(counting + offset).amount THEN
IF mysorted(counting).titles2 > mysorted(counting + offset).titles2 THEN
SWAP mysorted(counting), mysorted(counting + offset)
switch = counting
END IF
END IF
END IF
NEXT counting
Limit = switch - offset
LOOP WHILE switch
offset = offset \ 2
LOOP
' REGULAR NON-GRAPHICS, NON-COLOR OUTPUT FILE
USERFORMAT:
' ASSIGN INPUTFILE NAME TO NAME$
name$ = filename$
' PARSE NAME$ TO GET PATH AND NAME OF INPUT FILE
DO WHILE INSTR(name$, "\") <> 0
c = INSTR(filename$, "\")
name$ = MID$(name$, c + 1, 255)
D = c + D
path$ = LEFT$(filename$, D)
LOOP
' CHECK FOR 'M.DEF' EXTENSION OF NAME$
IF INSTR(name$, "M.DEF") <> 0 THEN name$ = LEFT$(name$, INSTR(name$, "M.DEF") - 1)
' TEST TO SEE WHAT FILE TO USE AS A TEMPLATE
IF INSTR(name$, ".") = 0 THEN
' THE INPUT FILENAME HAS NO EXTENSION...
OPEN name$ + ".TMP" FOR APPEND SHARED AS #1
' CHECK TO SEE IF THERE IS A TEMPLATE FILE IN THE DEFAULT DIRECTORY FOR THIS
IF LOF(1) = 0 THEN
CLOSE #1
KILL name$ + ".TMP"
OPEN "subject.tmp" FOR INPUT SHARED AS #1
templefile$ = "SUBJECT.TMP"
ELSE
IF LOF(1) > 0 THEN
CLOSE #1
OPEN name$ + ".TMP" FOR INPUT SHARED AS #1
templefile$ = name$ + ".TMP"
END IF
END IF
ELSE
' NO EXTENSION ON THIS FILE...USE DEFAULT SUBJECT.TMP FILE
OPEN "subject.tmp" FOR INPUT SHARED AS #1
templefile$ = "SUBJECT.TMP"
END IF
c = 0
D = 0
' OUTPUT FILE PROCESSING
outname$ = outputfile$
DO WHILE INSTR(outname$, "\") <> 0
c = INSTR(outputfile$, "\")
outname$ = MID$(outname$, c + 1, 255)
D = c + D
path$ = LEFT$(outputfile$, D)
LOOP
' PARSE OUTPUT FILENAME TO GET MESSAGE BASE NAME WITHOUT W.DEF
IF INSTR(outname$, "W.DEF") <> 0 THEN
outname$ = LEFT$(outname$, INSTR(outname$, "W.DEF") - 1)
END IF
' IF NAME IS TOO LONG SET VARIABLE TO TRUE
IF LEN(outname$) >= 7 THEN nametoolong = -1
' OPEN THE FILE FOR NON-GRAPHICS, NON-COLOR OUTPUT FILE, REGULAR *W.DEF FILE
OPEN outputfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputfile$
IF LEN(confname$) >= 20 THEN confname$ = LEFT$(confname$, 20)
IF LEN(confname$) < 20 THEN confname$ = LEFT$(confname$ + SPACE$(20), 20)
' IF NO MESSAGES, MAKE SURE DATES ARE RESET PROPERLY
IF y = 0 THEN
recentdate$ = "00-00-00"
olddate$ = "00-00-00"
END IF
' FORMAT 'MSG' OUTPUT OR, NUMBER OF MESSAGES IN MESSAGE BASE TO 3 CHARACTERS
IF y > 0 THEN
IF y >= 1 AND y < 10 THEN
messages$ = " " + LTRIM$(STR$(y))
ELSE
IF y >= 10 AND y < 100 THEN
messages$ = " " + LTRIM$(STR$(y))
ELSE
IF y >= 100 AND y < 1000 THEN
messages$ = LTRIM$(STR$(y))
END IF
END IF
END IF
END IF
IF y = 0 THEN messages$ = " 0"
' THIS ROUTINE READS TEMPLATE FILE AND REPLACES ALL VARIABLES WITH REAL INFO
' THEN CLOSES THE FILE
userformat2:
a = 0
b = 0
DO WHILE NOT EOF(1)
LINE INPUT #1, x$
IF INSTR(x$, "TODATExx") <> 0 THEN
z = INSTR(x$, "TODATExx")
x$ = MID$(x$, 1, (z - 1)) + recentdate$ + MID$(x$, z + 8, 255)
END IF
IF INSTR(x$, "FMDATExx") <> 0 THEN
z = INSTR(x$, "FMDATExx")
x$ = MID$(x$, 1, (z - 1)) + olddate$ + MID$(x$, z + 8, 255)
END IF
IF INSTR(x$, "MSG") <> 0 THEN
z = INSTR(x$, "MSG")
x$ = MID$(x$, 1, (z - 1)) + messages$ + MID$(x$, z + 3, 255)
END IF
IF INSTR(x$, "AREA") <> 0 THEN
z = INSTR(x$, "AREA")
x$ = MID$(x$, 1, (z - 1)) + RTRIM$(confname$) + MID$(x$, z + LEN(RTRIM$(confname$)), 255)
END IF
DO WHILE INSTR(x$, "###") <> 0 OR INSTR(x$, "SUBJECT890123456789012345") <> 0
IF INSTR(x$, "###") <> 0 THEN
z = INSTR(x$, "###")
IF INSTR(mysorted(a + 1).amount, CHR$(0)) = 0 THEN
x$ = MID$(x$, 1, (z - 1)) + mysorted(a + 1).amount + MID$(x$, z + 3, 255)
IF f >= a THEN a = a + 1
ELSE
x$ = MID$(x$, 1, (z - 1)) + " " + MID$(x$, z + 3, 255)
IF f >= a THEN a = a + 1
END IF
END IF
IF INSTR(x$, "SUBJECT890123456789012345") <> 0 THEN
z = INSTR(x$, "SUBJECT890123456789012345")
IF INSTR(mysorted(b + 1).titles2, CHR$(0)) = 0 THEN
x$ = MID$(x$, 1, (z - 1)) + mysorted(b + 1).titles2 + MID$(x$, z + 25, 255)
IF f >= b THEN b = b + 1
ELSE
x$ = MID$(x$, 1, (z - 1)) + SPACE$(25) + MID$(x$, z + 25, 255)
IF f >= b THEN b = b + 1
END IF
END IF
LOOP
PRINT #2, x$
LOOP
CLOSE
IF NOT asciido THEN
a$ = "Now on disk: "
count = 1
END IF
IF LEN(outfile$) > 21 THEN
IF count = 1 THEN outfile$ = "non-graphics"
IF count = 2 THEN outfile$ = "graphics"
IF count = 3 THEN outfile$ = "color-graphics"
END IF
a$ = a$ + LCASE$(outfile$)
LOCATE 2, 1
CALL center(a$, pad, ret)
count = count + 1
a$ = RTRIM$(a$)
IF asciido = false GOTO ASCIIMARK
IF colordo = false GOTO COLORMARK
LOCATE 23, 1
CALL delayit(3, false)
GOTO finish
ASCIIMARK:
asciido = true
' IF INPUTFILE NAME TOO LONG CAN'T MAKE GRAPHICS OR COLOR FILE
IF nametoolong THEN
GOTO finish
END IF
' CONTINUE TO PROCESS, UPDATE OUTPUT STRING FOR SCREEN DISPLAY
a$ = a$ + ", "
' CHECK FOR SPECIAL *G.TMP FILE
OPEN name$ + "G.TMP" FOR APPEND SHARED AS #1
IF LOF(1) = 0 THEN
CLOSE #1
KILL name$ + "G.TMP"
OPEN "subjectg.tmp" FOR INPUT SHARED AS #1
templefile$ = "SUBJECTG.TMP"
ELSE
CLOSE #1
OPEN name$ + "G.TMP" FOR INPUT SHARED AS #1
templefile$ = name$ + "G.TMP"
END IF
c = 0
D = 0
nameout$ = outputfile$
path$ = ""
DO WHILE INSTR(nameout$, "\") <> 0
c = INSTR(outputfile$, "\")
nameout$ = MID$(nameout$, c + 1, 255)
D = c + D
path$ = LEFT$(outputfile$, D)
LOOP
IF INSTR(nameout$, "W.DEF") <> 0 THEN
nameout$ = LEFT$(nameout$, INSTR(nameout$, "W.DEF") - 1)
END IF
outputgfile$ = path$ + nameout$ + "WG.DEF"
OPEN outputgfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputgfile$
GOTO userformat2
COLORMARK:
colordo = true
' CONTINUE TO PROCESS, UPDATE OUTPUT STRING FOR SCREEN DISPLAY
a$ = a$ + ", "
OPEN name$ + "C.TMP" FOR APPEND SHARED AS #1
IF LOF(1) = 0 THEN
CLOSE #1
KILL name$ + "C.TMP"
OPEN "subjectc.tmp" FOR INPUT SHARED AS #1
templefile$ = "SUBJECTC.TMP"
ELSE
CLOSE #1
OPEN name$ + "C.TMP" FOR INPUT SHARED AS #1
templefile$ = name$ + "C.TMP"
END IF
c = 0
D = 0
nameout$ = outputfile$
path$ = ""
DO WHILE INSTR(nameout$, "\") <> 0
c = INSTR(outputfile$, "\")
nameout$ = MID$(nameout$, c + 1, 255)
D = c + D
path$ = LEFT$(outputfile$, D)
LOOP
IF INSTR(nameout$, "W.DEF") <> 0 THEN
nameout$ = LEFT$(nameout$, INSTR(nameout$, "W.DEF") - 1)
END IF
outputcfile$ = path$ + nameout$ + "WC.DEF"
OPEN outputcfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputcfile$
GOTO userformat2
finish:
CLOSE
IF nametoolong THEN
COLOR 0, 7
LOCATE 2, 1
a$ = "Conference name too long to make Graphics or Color Welcome files"
CALL center(a$, pad, ret)
PRINT
LOCATE 22, 1
CALL delayit(20, true)
END IF
GOTO theend
showcommands:
CLS
a$ = "Required format for SUBJECT.EXE (Version 3.0):"
CALL center(a$, pad, ret)
a$ = "══════════════════════════════════════════════"
CALL center(a$, pad, ret)
a$ = "SUBJECT I:file O:file C:name (? = Help)"
CALL center(a$, pad, ret)
PRINT
a$ = "Template (SUBJECT?.TMP) files must be on the default drive/directory"
CALL center(a$, pad, ret)
a$ = "For complete compatibility, use 6 characters or less for your RBBS-PC"
CALL center(a$, pad, ret)
a$ = "Messages files (e.g. 'optionM.DEF')"
CALL center(a$, pad, ret)
PRINT
a$ = "Examples:"
CALL center(a$, pad, ret)
a$ = "SUBJECT i:c:\rbbs\rbbspcM.DEF o:c:\rbbs\rbbspcW.DEF c:rbbs-pc "
CALL center(a$, pad, ret)
a$ = "SUBJECT i:binkM.DEF o:binkW.DEF c:binkleyterm "
CALL center(a$, pad, ret)
PRINT
a$ = "Required command-line parameters:"
CALL center(a$, pad, ret)
a$ = "i: - Name of Input RBBS-PC Messages file to read"
CALL center(a$, pad, ret)
a$ = "o: - Name of Output file to create"
CALL center(a$, pad, ret)
a$ = "c: - Name of Conference--Do NOT use any [SPACE] characters"
CALL center(a$, pad, ret)
IF NOT helptext THEN
IF LEN(COMMAND$) > 0 THEN
PRINT
a$ = "Correct the current command-line:"
CALL center(a$, pad, ret)
a$ = "SUBJECT " + COMMAND$
CALL center(a$, pad, ret)
END IF
ELSE
PRINT
a$ = "Options:"
CALL center(a$, pad, ret)
a$ = "SUBJECT also looks for special *.TMP files so that you can customize"
CALL center(a$, pad, ret)
a$ = "Welcome files for your conferences. Rather than using the default "
CALL center(a$, pad, ret)
a$ = "SUBJECT?.TMP files, you can create your own for any particular conference"
CALL center(a$, pad, ret)
a$ = "and SUBJECT will look for that one first, and use it, if it matches the"
CALL center(a$, pad, ret)
a$ = "name of the message file (e.g. 'other.TMP,' 'otherG.TMP,' or 'otherC.TMP'"
CALL center(a$, pad, ret)
a$ = "for the Conference 'otherM.DEF.' Read documentation for more details."
CALL center(a$, pad, ret)
END IF
PRINT
CALL delayit(120, true)
GOTO theend
HANDLER:
listen$ = "t180 o1 p2 p8 l8 ggg l1 e-"
fate$ = "t140 p24 p8 l8 fff t110 l1 d P2"
PLAY listen$ + fate$
number = ERR
IF number = 63 THEN
CLOSE #1
KILL filename$
OPEN "subject.err" FOR APPEND SHARED AS #2
LOCATE 11, 1
PRINT SPACE$(80 * 3);
LOCATE 12, 1
COLOR 0, 7, 0
a$ = "Basic Error 63: Specified RBBS-PC Messages file NOT FOUND!"
CALL center(a$, pad, 0)
COLOR 7, 0, 0
PRINT #2, "An error has occured running SUBJECT.EXE at:"
PRINT #2, " Date: "; DATE$; "; Time: "; TIME$
PRINT #2, " Processing Messages file: "; filename$
PRINT #2, " Check if the Message file exists in the proper directory."
PRINT #2, "---"
PRINT
LOCATE 23
CALL delayit(30, true)
ON ERROR GOTO theend
ELSE
CLOSE
LOCATE 11, 1
PRINT SPACE$(80 * 4);
LOCATE 12, 1
COLOR 0, 7, 0
a$ = "SUBJECT encountered untrapped error number " + LTRIM$(STR$(number))
CALL center(a$, pad, 1)
COLOR 7, 0, 0
COLOR 0, 7, 0
a$ = "Refer to your BASIC manual for more information about this Error code"
CALL center(a$, pad, 1)
COLOR 7, 0, 0
OPEN "subject.err" FOR APPEND SHARED AS #2
PRINT #2, "An error has occured running SUBJECT.EXE at:"
PRINT #2, " Date: "; DATE$; "; Time: "; TIME$
PRINT #2, " Processing Messages file: "; filename$
PRINT #2, " SUBJECT.EXE encountered untrapped error number"; number
PRINT #2, " Read your BASIC manual for more information about this Error code."
PRINT #2, "---"
LOCATE 23
CALL delayit(30, true)
ON ERROR GOTO theend
END IF
theend:
' FOR RESTORING, USE THIS
page = 0
scrmode = -1
DSEG = VARSEG(SCR(1))
DOFS = VARPTR(SCR(1))
CALL DSCRREST(DSEG, DOFS, page, scrmode)
LOCATE restrow, restcol
END
SUB center (a$, pad, ret)
a$ = SPACE$(pad) + RTRIM$(LTRIM$(a$)) + SPACE$(pad)
col! = ((80 - LEN(a$)) / 2)
IF INSTR(STR$(col!), ".5") <> 0 THEN col! = col! - .5
LOCATE , col! + 1
PRINT a$;
IF ret <> 0 THEN PRINT
END SUB
SUB comline (NumArgs, Args$(), MaxArgs) STATIC
CONST false = 0, true = NOT false
NumArgs = 0
in = false
c1$ = COMMAND$
L = LEN(c1$)
FOR I = 1 TO L
c$ = MID$(c1$, I, 1)
IF (c$ <> " " AND c$ <> CHR$(9)) THEN
IF NOT in THEN
IF NumArgs = MaxArgs THEN EXIT FOR
NumArgs = NumArgs + 1
in = true
END IF
Args$(NumArgs) = Args$(NumArgs) + c$
ELSE
in = false
END IF
NEXT I
END SUB
SUB delayit (secs, display)
COLOR 15, 4
start! = TIMER
DO WHILE INKEY$ = ""
LOCATE , 1
finish! = TIMER
IF display THEN
a$ = "Wait " + LTRIM$(STR$(INT(secs - (finish! - start!)))) + " seconds or press any key to continue..."
CALL center(a$, 1, 0)
END IF
IF finish! - start! > secs THEN
EXIT DO
END IF
FOR x = 1 TO 500
IF INKEY$ <> "" THEN
EXIT DO
END IF
NEXT x
LOOP
END SUB